home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / utils / atomic-extents.el.z / atomic-extents.el
Encoding:
Text File  |  1998-05-21  |  3.8 KB  |  111 lines
  1. ;;; atomic-extents.el --- treat regions of text as a single object
  2.  
  3. ;; Copyright (C) 1993 Free Software Foundation, Inc.
  4. ;; Created: 21-Dec-93, Chuck Thompson <cthomp@cs.uiuc.edu>
  5. ;; Keywords: extensions
  6. ;; Changed: 08-Aug-94, Heiko Muenkel <muenkel@tnt.uni-hannover.de>
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the 
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Point is not allowed to fall inside of an atomic extent.  This has
  26. ;;; the effect of making all text covered by an atomic extent be
  27. ;;; treated as a single object.  Normally point will be adjusted to an
  28. ;;; end of an atomic extent in the direction of motion.  If point
  29. ;;; appears inside of an atomic extent (via goto-char for example),
  30. ;;; point will be adjusted to the side closest to the entry point.
  31.  
  32. ;;; Synched up with: Not in FSF.
  33.  
  34. ;;; To make an extent atomic use the command:
  35. ;;;    (set-extent-property #<extent obj> 'atomic t)
  36.  
  37. ;;; Known bug: the atomic property is not detected when sweeping
  38. ;;; regions with the mouse until after the mouse button is released.
  39. ;;; The release point will then be treated as if it had been reached
  40. ;;; using 'goto-char.
  41.  
  42. ;;; atomic-extent-goto-char-p is defined in editfns.c
  43.  
  44. (provide 'atomic-extents)
  45.  
  46. (defvar atomic-extent-old-point nil
  47.   "The value of point when pre-command-hook is called.
  48. Used to determine the direction of motion.")
  49.  
  50. (defun atomic-extent-pre-hook ()
  51.   (setq atomic-extent-old-point (point))
  52.   (setq atomic-extent-goto-char-p nil))
  53.  
  54. (defun atomic-extent-post-hook ()
  55.   (let ((extent (extent-at (point) nil 'atomic)))
  56.     (if extent
  57.     (let ((begin (extent-start-position extent))
  58.           (end (extent-end-position extent))
  59.           (pos (point))
  60.           (region-set (and (point) (mark))))
  61.       (if (eq this-command
  62.           'x-set-point-and-insert-selection)
  63.           (delete-region (region-beginning) (region-end)))
  64.       (if (/= pos begin)
  65.           (if atomic-extent-goto-char-p
  66.           (progn
  67.             (if (> (- pos begin) (- end pos))
  68.             (goto-char end)
  69.               (goto-char begin)))
  70.         (if (> pos atomic-extent-old-point)
  71.             (goto-char end)
  72.           (goto-char begin))))
  73.       (if (and region-set (/= pos begin))
  74.           (progn
  75.         (run-hooks 'zmacs-update-region-hook)
  76.         (x-store-cutbuffer (buffer-substring (region-beginning)
  77.                              (region-end)))
  78.         )))))
  79.   (if (mark)
  80.       (progn
  81.     (exchange-point-and-mark t)
  82.     (let ((extent (extent-at (point) nil 'atomic)))
  83.       (if extent
  84.           (let ((begin (extent-start-position extent))
  85.             (end (extent-end-position extent))
  86.             (pos (point))
  87.             (region-set (and (point) (mark))))
  88.         (if (/= pos begin)
  89.             (if atomic-extent-goto-char-p
  90.             (progn
  91.               (if (> (- pos begin) (- end pos))
  92.                   (goto-char end)
  93.                 (goto-char begin)))
  94.               (if (> pos atomic-extent-old-point)
  95.               (goto-char end)
  96.             (goto-char begin))))
  97.         (if (and region-set (/= pos begin))
  98.             (progn
  99.               (run-hooks 'zmacs-update-region-hook)
  100.               (x-store-cutbuffer (buffer-substring (region-beginning)
  101.                                (region-end)))
  102.         (message "%d, %d" (region-beginning) (region-end))
  103.               )))))
  104.     (exchange-point-and-mark t)))
  105.   )
  106.  
  107. (add-hook 'pre-command-hook 'atomic-extent-pre-hook)
  108. (add-hook 'post-command-hook 'atomic-extent-post-hook)
  109.  
  110. ;;; atomic-extents.el ends here
  111.